home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / ctop.scm < prev    next >
Text File  |  1995-10-13  |  8KB  |  260 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; File processing, etc. for compiler
  5.  
  6.  
  7. ; Compile-form and compile-file return templates, suitable for
  8. ;  execution via (invoke-closure (make-closure <template> <arbitrary>)).
  9.  
  10. (define (compile-form form p)
  11.   (compile-scanned-forms (scan-forms (list form) p #f)
  12.              p #f #f))
  13.  
  14.  
  15. ; Compile a file.  The entire file is first scanned to process all
  16. ; definitions.  Then it's compiled.  The result is a template.
  17.  
  18. (define (compile-file filename p)    ; => thunk template
  19.   (let* ((scanned-forms (scan-file filename p))
  20.      (o-port (current-output-port))
  21.      (template (compile-scanned-forms scanned-forms p filename o-port)))
  22.     (newline o-port)
  23.     (force-output o-port)
  24.     template))
  25.  
  26.  
  27. ; compile-and-run-{form,file} are the same as compile-{form, file},
  28. ; but instead of returning templates, they produce a template for each
  29. ; form as the form is compiled.  Each template is passed to a
  30. ; specified action procedure.
  31.  
  32. (define (compile-and-run-forms forms p filename run noisy?)
  33.   (compile-and-run-scanned-forms (scan-forms forms p filename)
  34.                  p filename run noisy?))
  35.  
  36. (define (compile-and-run-file filename p run noisy?)
  37.   (compile-and-run-scanned-forms (really-scan-file filename p noisy?)
  38.                  p filename run
  39.                  noisy?))
  40.  
  41. ; --------------------
  42.  
  43. ; If non-noisy, this tail-recurs to last form.
  44.  
  45. (define (compile-and-run-scanned-forms scanned-forms p filename run noisy?)
  46.   (let* ((do-it (lambda (scanned-form)
  47.           (compile-scanned-forms (list scanned-form)
  48.                      p filename noisy?)))
  49.      (do-them (lambda ()
  50.             (if (null? scanned-forms)
  51.             (compile-scanned-forms '() p #f #f)
  52.             (do-it (do ((scanned-forms scanned-forms
  53.                            (cdr scanned-forms)))
  54.                    ((null? (cdr scanned-forms))
  55.                     (car scanned-forms))
  56.                  (run (do-it (car scanned-forms)))))))))
  57.     (if noisy?
  58.     (call-with-values (lambda ()
  59.                 (run (do-them)))
  60.       (lambda results
  61.         (newline noisy?)
  62.         (force-output noisy?)
  63.         (apply values results)))
  64.     (run (do-them)))))
  65.  
  66.  
  67. ; compile-scanned-forms: returns a template.
  68.  
  69. (define (compile-scanned-forms scanned-forms p filename noisy? . env-option)
  70.   (let ((cenv (bind-source-file-name
  71.            filename
  72.            (if (null? env-option)
  73.            (package->environment p)
  74.            (car env-option)))))
  75.     (segment->template
  76.      (if (null? scanned-forms)
  77.      (deliver-value (instruction (enum op unspecific))
  78.             (return-cont #f))
  79.      (let recur ((scanned-forms scanned-forms))
  80.        (if (null? (cdr scanned-forms))
  81.            (compile-scanned-form (car scanned-forms) cenv
  82.                      (return-cont #f) noisy?)
  83.            (careful-sequentially 
  84.         (compile-scanned-form (car scanned-forms) cenv
  85.                       an-ignore-values-cont noisy?)
  86.         ;; Cf. compile-begin
  87.         (recur (cdr scanned-forms))
  88.         0
  89.         (return-cont #f)))))
  90.      filename
  91.      #f)))                ;pc-in-segment = #f
  92.  
  93. ; Compile a single top-level form, returning a segment.
  94.  
  95. (define (compile-scanned-form node cenv cont noisy?)
  96.   (cond ((define-node? node)
  97.      (let ((segment (compile-definition node cenv cont noisy?)))
  98.        (if noisy?
  99.            (begin (write-char #\. noisy?)
  100.               (force-output noisy?)))
  101.        segment))
  102.     ((define-syntax-node? node)
  103.      (deliver-value (instruction (enum op unspecific)) cont))
  104.     (else
  105.      (compile-top node cenv 0 cont))))
  106.  
  107.  
  108. ; Definitions must be treated differently from assignments: we must
  109. ; use SET-CONTENTS! instead of SET-GLOBAL! because the SET-GLOBAL!
  110. ; instruction traps if an attempt is made to store into an undefined
  111. ; location.
  112.  
  113. (define compile-definition
  114.   (let ((location-contents-offset 0))    ;should be found in stob-data
  115.     (lambda (node cenv cont noisy?)
  116.       (let* ((form (node-form node))
  117.          (name (cadr form))
  118.          (loc (binding-place (lookup cenv name))))
  119.     (sequentially (instruction-with-location (enum op literal)
  120.                          (lambda () loc))
  121.               (instruction (enum op push))
  122.               (compile-top (caddr form)
  123.                    cenv
  124.                    1
  125.                    (named-cont name))
  126.               (deliver-value
  127.                (instruction (enum op stored-object-set!)
  128.                     (enum stob location)
  129.                     location-contents-offset)
  130.                cont))))))
  131.  
  132. ; --------------------
  133. ; Hairy stuff for dealing with undefined variables.
  134.  
  135. ; GET-LOCATION returns a thunk that will obtain a location to be
  136. ; stored away in a template.  The hair here results from a desire to
  137. ; be able to recover from errors.
  138.  
  139. (define (get-location binding cenv name want-type)
  140.   (if (binding? binding)
  141.       (let ((win (lambda ()
  142.            (note-caching cenv name (binding-place binding)))))
  143.     (if (compatible-types? (binding-type binding) want-type)
  144.         win
  145.         (if (variable-type? want-type)
  146.         (get-location-for-unassignable cenv name)
  147.         (begin (warn "invalid variable reference" name)
  148.                win))))
  149.       (get-location-for-undefined cenv name)))
  150.  
  151. (define (get-location-for-undefined cenv name)
  152.   (if (generated? name)
  153.       (get-location-for-undefined (generated-env name)
  154.                   (generated-symbol name))
  155.       (let ((p (grumble cenv)))
  156.     (note-undefined! p name)
  157.     (if (package? p)
  158.         (lambda ()
  159.           (package-note-caching p name
  160.                     (location-for-reference p name)))
  161.         (lambda ()
  162.           (make-undefined-location name))))))
  163.             
  164. (define (get-location-for-unassignable cenv name)
  165.   (if (generated? name)
  166.       (get-location-for-unassignable (generated-env name)
  167.                      (generated-symbol name))
  168.       (let ((p (grumble cenv)))
  169.     (warn "invalid assignment" name)
  170.     (if (package? p)
  171.         (lambda () (location-for-assignment p name))
  172.         (lambda () (make-undefined-location name))))))
  173.  
  174. (define (package-accessor-on-demand id init)
  175.   (lambda (p)
  176.     (or (package-get p id)
  177.     (let ((foo (init)))
  178.       (package-put! p id foo)
  179.       foo))))
  180.  
  181. (define (location-on-demand accessor)
  182.   (lambda (p name)
  183.     (let ((table (accessor p)))
  184.       (or (table-ref table name)
  185.       (let ((new (make-new-location p name)))
  186.         (table-set! table name new)
  187.         new)))))
  188.  
  189. ; Create undefined variable -> location tables on demand.
  190.  
  191. (define package-undefineds
  192.   (package-accessor-on-demand 'undefineds
  193.                   (lambda () (make-table name-hash))))
  194.  
  195. (define location-for-reference
  196.   (let ((get-undefined (location-on-demand package-undefineds)))
  197.     (lambda (p name)
  198.       (let loop ((opens (package-opens p)))
  199.     (if (null? opens)
  200.         (get-undefined p name)
  201.         (if (interface-ref (structure-interface (car opens))
  202.                    name)
  203.         (location-for-reference (structure-package (car opens)) name)
  204.         (loop (cdr opens))))))))
  205.  
  206. (define package-undefined-but-assigneds
  207.   (package-accessor-on-demand 'undefined-but-assigneds
  208.                   (lambda () (make-table name-hash))))
  209.  
  210. (define location-for-assignment
  211.   (location-on-demand package-undefined-but-assigneds))
  212.  
  213.  
  214. (define (note-caching cenv name place)
  215.   (if (generated? name)
  216.       (note-caching (generated-env name)
  217.             (generated-symbol name)
  218.             place)
  219.       (let ((p (grumble cenv)))
  220.     (if (package? p)
  221.         (package-note-caching p name place)
  222.         place))))
  223.  
  224. (define (grumble cenv)
  225.   (cond ((procedure? cenv)
  226.      ;; This returns #f if package is stable (static linking).
  227.      (extract-package-from-environment cenv))
  228.     ((package? cenv) cenv)
  229.     ((structure? cenv) (structure-package cenv))))
  230.  
  231. ; --------------------
  232. ; Make a startup procedure from a list of initialization thunks.  This
  233. ; is only used by the static linker.
  234.  
  235. (define (make-startup-procedure inits resumer)
  236.   (let ((nargs 3))
  237.     (segment->template
  238.       (reduce (lambda (init seg)
  239.         (sequentially
  240.          (maybe-push-continuation
  241.           (sequentially
  242.            (instruction-with-literal (enum op closure) init)
  243.            (instruction (enum op call) 0))
  244.           nargs
  245.           an-ignore-values-cont)
  246.          seg))
  247.           (sequentially
  248.            (maybe-push-continuation
  249.           (sequentially
  250.            (instruction-with-literal (enum op closure) resumer)
  251.            (instruction (enum op call) 0))
  252.           nargs
  253.           (fall-through-cont #f #f))
  254.            ;; was (compile resumer p nargs (fall-through-cont))
  255.            (instruction (enum op call) nargs))
  256.           inits)
  257.       #f #f)))
  258.  
  259. (define an-ignore-values-cont (ignore-values-cont #f #f))
  260.